home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Tools / Languages / MacHaskell 2.2 / util / constructors.scm < prev    next >
Encoding:
Text File  |  1994-09-27  |  8.8 KB  |  362 lines  |  [TEXT/CCL2]
  1. ;;; This file contains ast construction functions.  These
  2. ;;; functions are supplied for commonly used ast structures to
  3. ;;; avoid the longer `make' normally required.
  4.  
  5. ;;; Function names are the type names with a `**' prefix.  For reference
  6. ;;; nodes, the /def for builds the node from a definition instead of a name.
  7.  
  8. ;;; Note: maybe these should be made automagicly someday.
  9.  
  10. ;;; from exp-structs:
  11.  
  12. (define (**lambda args body)
  13.   (**lambda/pat (map (function **pat) args) body))
  14.  
  15. (define (**lambda/pat pats body)
  16.   (if (null? pats)
  17.       body
  18.       (make lambda (pats pats) (body body))))
  19.  
  20.  
  21.  
  22. ;;; Make a case expression.
  23.  
  24. (define (**case exp alts)
  25.   (make case (exp exp) (alts alts)))
  26.  
  27. (define (**alt/simple pat exp)
  28.   (**alt pat 
  29.      (list (make guarded-rhs
  30.              (guard (make omitted-guard))
  31.              (rhs exp)))
  32.      '()))
  33.  
  34. (define (**alt pat rhs-list where-decls)
  35.   (make alt (pat pat) (rhs-list rhs-list) (where-decls where-decls)))
  36.  
  37. (define (**let decls body)
  38.   (if decls
  39.       (make let (decls decls) (body body))
  40.       body))
  41.  
  42. (define (**if test then-exp else-exp)
  43.   (make if (test-exp test) (then-exp then-exp) (else-exp else-exp)))
  44.  
  45. (define (**app fn . args)  ; any number of args
  46.   (**app/l fn args))
  47.  
  48. (define (**app/l fn args)  ; second args is a list
  49.   (if (null? args)
  50.       fn
  51.       (**app/l (make app (fn fn) (arg (car args)))
  52.            (cdr args))))
  53.  
  54. (define (**var name)
  55.   (make var-ref (name name) (var (dynamic *undefined-def*)) (infix? '#f)))
  56.  
  57. (define (**var/def def)  ; arg is an entry
  58.   (make var-ref (var def) (name (def-name def)) (infix? '#f)))
  59.         
  60. (define (**con/def def)
  61.   (make con-ref (name (def-name def)) (con def) (infix? '#f)))
  62.  
  63. (define (**cons x y)
  64.   (**app (**con/def (core-symbol ":")) x y))
  65.  
  66. (define (**null)
  67.   (**con/def (core-symbol "Nil")))
  68.  
  69. (define (**list . args)
  70.   (**list/l args))
  71.  
  72. (define (**list/l args)
  73.   (if (null? args)
  74.       (**null)
  75.       (**cons (car args)
  76.           (**list/l (cdr args)))))
  77.  
  78. (define (**int x)
  79.   (make integer-const (value x)))
  80.  
  81. (define (**char x)
  82.   (make char-const (value x)))
  83.  
  84. (define (**string x)
  85.   (make string-const (value x)))
  86.  
  87. (define (**bool x)
  88.   (if x (**con/def (core-symbol "True")) (**con/def (core-symbol "False"))))
  89.  
  90. (define (**listcomp exp quals)
  91.   (make list-comp (exp exp) (quals quals)))
  92.  
  93. (define (**gen pat exp)
  94.   (make qual-generator (pat (**pat pat)) (exp exp)))
  95.  
  96. (define (**omitted-guard)
  97.   (make omitted-guard))
  98.  
  99. (define (**con-number exp algdata)
  100.   (make con-number (type algdata) (value exp)))
  101.  
  102. (define (**sel con exp i)
  103.   (make sel (constructor con) (value exp) (slot i)))
  104.  
  105. (define (**is-constructor exp con)
  106.   (make is-constructor (value exp) (constructor con)))
  107.  
  108. ;;; From valdef-structs
  109.  
  110. (define (**signdecl vars type)
  111.   (make signdecl (vars (map (function **var) vars)) (signature type)))
  112.  
  113. (define (**signdecl/def vars type)
  114.   (make signdecl (vars (map (function **var/def) vars)) (signature type)))
  115.  
  116. (define (**define name args val)
  117.   (**valdef (**pat name) (map (function **pat) args) val))
  118.  
  119. (define (**valdef/def var exp)
  120.   (**valdef/pat (**var-pat/def var) exp))
  121.  
  122. (define (**valdef/pat pat exp)
  123.   (**valdef pat '() exp))
  124.  
  125. (define (**valdef lhs args rhs)
  126.   (make valdef
  127.     (lhs lhs)
  128.     (definitions
  129.       (list (make single-fun-def
  130.               (args args)
  131.               (rhs-list
  132.                 (list (make guarded-rhs
  133.                     (guard (**omitted-guard))
  134.                     (rhs rhs))))
  135.               (where-decls '())
  136.               (infix? '#f))))))
  137.  
  138.  
  139. ;;; Patterns (still in valdef-structs)
  140.  
  141. ;;; The **pat function converts a very simple lisp-style pattern representation
  142. ;;; into corresponding ast structure.  The conversion:
  143. ;;;   a) _ => wildcard
  144. ;;;   b) a symbol => Var pattern
  145. ;;;   c) an integer / string => const pattern
  146. ;;;   d) a list of pats starting with 'tuple => Pcon
  147. ;;;   e) a list of pats starting with a con definition => Pcon
  148. ;;;   f) a list of pats starting with 'list => a list pattern
  149.  
  150. (define (**pat v)
  151.   (cond ((eq? v '_) (**wildcard-pat))
  152.     ((symbol? v)
  153.      (make var-pat (var (**var v))))
  154.     ((var? v)
  155.      (make var-pat (var (**var/def v))))
  156.     ((integer? v)
  157.      (make const-pat (value (**int v))))
  158.     ((string? v)
  159.      (make const-pat (value (**string v))))
  160.     ((and (pair? v) (eq? (car v) 'tuple))
  161.      (**pcon/tuple (map (function **pat) (cdr v))))
  162.     ((and (pair? v) (eq? (car v) 'list))
  163.      (make list-pat (pats (map (function **pat) (cdr v)))))
  164.     ((and (pair? v) (con? (car v)))
  165.      (**pcon/def (car v) (map (function **pat) (cdr v))))
  166.     (else
  167.      (error "Bad pattern in **pat: ~A~%" v))))
  168.  
  169. (define (**pcon name pats)
  170.   (make pcon (name (add-con-prefix/symbol name))
  171.          (con (dynamic *undefined-def*)) (pats pats) (infix? '#f)))
  172.  
  173. (define (**pcon/def def pats)
  174.   (make pcon (name (def-name def)) (con def) (pats pats) (infix? '#f)))
  175.  
  176. (define (**pcon/tuple pats)
  177.   (**pcon/def (tuple-constructor (length pats)) pats))
  178.  
  179. ;;; Make a variable pattern from the var
  180.  
  181. (define (**var-pat/def var)
  182.   (make var-pat
  183.     (var (**var/def var))))
  184.  
  185. (define (**wildcard-pat)
  186.   (make wildcard-pat))
  187.  
  188.  
  189. ;;; Either make a tuple, or return the single element of a list.
  190.  
  191. (define (**tuple-pat pats)
  192.   (cond ((null? pats)
  193.      (**pcon/def (core-symbol "UnitConstructor") '()))
  194.     ((null? (cdr pats))
  195.      (car pats))
  196.     (else
  197.      (**pcon/tuple pats))))
  198.  
  199.  
  200. ;;; From type-structs.scm
  201.  
  202. (define (**tycon name args)
  203.   (make tycon (name name) (args args) (def (dynamic *undefined-def*))))
  204.  
  205. (define (**tycon/def def args)
  206.   (make tycon (name (def-name def)) (def def) (args args)))
  207.  
  208. (define (**tyvar name)
  209.   (make tyvar (name name)))
  210.  
  211. (define (**signature context type)
  212.   (make signature (context context) (type type)))
  213.  
  214. (define (**class/def def)
  215.   (make class-ref (name (def-name def)) (class def)))
  216.  
  217. (define (**context tycls tyvar)
  218.   (make context (class tycls) (tyvar tyvar)))
  219.  
  220. ;;; From tc-structs
  221.  
  222. (define (**ntyvar)
  223.   (make ntyvar (value '#f) (context '()) (dict-params '())))
  224.  
  225. (define (**ntycon tycon args)
  226.   (make ntycon (tycon tycon) (args args)))
  227.  
  228. (define (**arrow . args) 
  229.   (**arrow/l args))
  230.  
  231. (define (**arrow/l args)
  232.   (if (null? (cdr args))
  233.       (car args)
  234.       (**ntycon (core-symbol "Arrow")
  235.         (list (car args) (**arrow/l (cdr args))))))
  236.  
  237. (define (**arrow/l-2 args final-val)
  238.   (if (null? args)
  239.       final-val
  240.       (**ntycon (core-symbol "Arrow")
  241.         (list (car args) (**arrow/l-2 (cdr args) final-val)))))
  242.  
  243. (define (**list-of arg)
  244.   (**ntycon (core-symbol "List") (list arg)))
  245.  
  246. (define (**recursive-placeholder var edecls)
  247.   (make recursive-placeholder (var var) (exp '#f)
  248.     (enclosing-decls edecls)))
  249.  
  250. (define (**dict-placeholder class tyvar edecls var)
  251.   (make dict-placeholder
  252.     (class class) (exp '#f) (overloaded-var var)
  253.     (tyvar tyvar) (enclosing-decls edecls)))
  254.  
  255. (define (**method-placeholder method tyvar edecls var)
  256.   (make method-placeholder
  257.     (method method) (exp '#f) (overloaded-var var)
  258.     (tyvar tyvar) (enclosing-decls edecls)))
  259.  
  260. ;;; Some less primitive stuff
  261.  
  262. (define (**tuple-sel n i exp)  ;; 0 <= i < n
  263.   (if (eqv? n 1)
  264.       exp
  265.       (**sel (tuple-constructor n) exp i)))
  266.  
  267. (define (**abort msg)
  268.   (**app (**var/def (core-symbol "error"))
  269.      (**string msg)))
  270.  
  271. (define (**tuple/l args)
  272.   (cond ((null? args)
  273.      (**con/def (core-symbol "UnitConstructor")))
  274.     ((null? (cdr args))
  275.      (car args))
  276.     (else
  277.      (**app/l (**con/def (tuple-constructor (length args)))
  278.           args))))
  279.  
  280. (define (**tuple . args)
  281.   (**tuple/l args))
  282.  
  283. (define (**tuple-type/l args)
  284.   (cond ((null? args)
  285.      (**tycon/def (core-symbol "UnitType") '()))
  286.     ((null? (cdr args))
  287.      (car args))
  288.     (else
  289.      (**tycon/def (tuple-tycon (length args)) args))))
  290.  
  291. (define (**tuple-type . args)
  292.   (**tuple-type/l args))
  293.  
  294. (define (**arrow-type . args)
  295.   (**arrow-type/l args))
  296.  
  297. (define (**arrow-type/l args)
  298.   (if (null? (cdr args))
  299.       (car args)
  300.       (**tycon/def (core-symbol "Arrow") (list (car args)
  301.                            (**arrow-type/l (cdr args))))))
  302.  
  303. (define (**fromInteger x)
  304.   (**app (**var/def (core-symbol "fromInteger")) x))
  305.  
  306. (define (**fromRational x)
  307.   (**app (**var/def (core-symbol "fromRational")) x))
  308.  
  309. (define (**gtyvar n)
  310.   (make gtyvar (varnum n)))
  311.  
  312. (define (**gtype context type)
  313.   (make gtype (context context) (type type)))
  314.  
  315. (define (**fixity a p)
  316.   (make fixity (associativity a) (precedence p)))
  317.  
  318. (define (**ntycon/tuple . args)
  319.   (let ((arity  (length args)))
  320.     (**ntycon (tuple-tycon arity) args)))
  321.  
  322. (define (**ntycon/arrow . args)
  323.   (**ntycon/arrow-l args))
  324.  
  325. (define (**ntycon/arrow-l args)
  326.   (let ((arg (if (integer? (car args))
  327.          (**gtyvar (car args))
  328.          (car args))))
  329.     (if (null? (cdr args))
  330.     arg
  331.     (**arrow arg (**ntycon/arrow-l (cdr args))))))
  332.  
  333. (define (**save-old-exp old new)
  334.   (make save-old-exp (old-exp old) (new-exp new)))
  335.  
  336.  
  337.  
  338. ;;; These are used by the CFN.
  339.  
  340. (define (**case-block block-name exps)
  341.   (make case-block
  342.     (block-name block-name)
  343.     (exps exps)))
  344.  
  345. (define (**return-from block-name exp)
  346.   (make return-from
  347.     (block-name block-name)
  348.     (exp exp)))
  349.  
  350. (define (**and-exp . exps)
  351.   (cond ((null? exps)
  352.      (**con/def (core-symbol "True")))
  353.     ((null? (cdr exps))
  354.      (car exps))
  355.     (else
  356.      (make and-exp (exps exps)))))
  357.  
  358. ;;; Cast overrides the type system
  359.  
  360. (define (**cast x)
  361.   (make cast (exp x)))
  362.